home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / busy.tcl.z / busy.tcl
Text File  |  2002-07-08  |  6KB  |  214 lines
  1. # 
  2. # busy.tcl
  3. #
  4. # Busy feedback.
  5. #
  6. # Copyright (c) 1993 Xerox Corporation.
  7. # Use and copying of this software and preparation of derivative works based
  8. # upon this software are permitted. Any distribution of this software or
  9. # derivative works must comply with all applicable United States export
  10. # control laws. This software is made available AS IS, and Xerox Corporation
  11. # makes no warranty about the software, its performance or its conformity to
  12. # any specification.
  13.  
  14. proc Busy_Init {} {
  15.     global busy exmh
  16.  
  17.     Preferences_Add "Busy Indicator" \
  18. "These items affect how exmh indicates it is busy." \
  19.     [list \
  20.         {busy(style) busyStyle {CHOICE cursor icon cursorAll none} {How to indicate busy}
  21. "icon - show a bitmap in the faces display.
  22. cursor - change the cursor to a busy indicator.
  23. cursorAll - Like cursor, but hits all widgets and takes longer.
  24. none - do nothing."} \
  25.     [list busy(cursor) busyCursor watch {Cursor for busy indicator} \
  26. "This is a TK specification for a cursor.  You can use a standard
  27. X cursor, like \"watch\", or provide your own bitmaps and mask
  28. with \"@filename\".  You can optionally provide foreground and
  29. background colors. (See Tk_GetCursor for complete details).
  30. A final twist is that relative pathnames are munged to be
  31. absolute pathnames under $exmh(library)
  32. Examples include:
  33.     watch        - standard watch
  34.     watch blue        - a clear and blue watch
  35.     watch blue white    - a white and blue watch
  36.     @timer.bitmap black     - 16x16 timer/watch (need fg color!)
  37.     @hourglass1.bitmap black    - Standard wish hourglass
  38.     @hourglass2.bitmap blue    - Large 32x32 hourglass, in blue
  39.     @hourglass2.bitmap hourglass2.mask red black - (need two colors!)
  40.     @/usr/foo/exmh/bar.mask /usr/foo/exmh/bar.bitmap black yellow
  41. "] \
  42.     [list busy(bitmap) busyBitmap @hourglass2.bitmap {Bitmap for busy indicator} \
  43. "This is a TK specification for a bitmap.  There are only a few
  44. boring built-in bitmaps, so mostly you specify these with the
  45. @pathname syntax.  A relative pathname is munged to be an
  46. absolute pathname under $exmh(library)
  47. Examples include:
  48.     @hourglass1.bitmap        - Standard wish hourglass
  49.     @hourglass1.bitmap blue    - Blue wish hourglass
  50.     @/usr/foo/exmh/bar.bitmap
  51. "] \
  52.     ]
  53.     set busy(color) black
  54.     trace variable busy(cursor) w BusyFixupCursor
  55.     BusyFixupCursor
  56.  
  57.     trace variable busy(bitmap) w BusyFixupBitmap
  58.     BusyFixupBitmap
  59.  
  60. }
  61. proc BusyFixupCursor { args } {
  62.     global busy exmh
  63.     # busy(cursor) could be
  64.     # @foo.cursor bar.cursor color color
  65.     # Here we insert the exmh library
  66.     switch -regexp $busy(cursor) {
  67.     {^@[^/]} {
  68.         regsub @(.*) $busy(cursor) $exmh(library)/\\1 newfile
  69.         if ![file exists [lindex $newfile 0]] {
  70.         Exmh_Status "Invalid file [lindex $newfile 0]"
  71.         return
  72.         }
  73.         if {[llength $newfile] > 2} {
  74.         regsub {([^ ]*) (.*)} $newfile "\\1 $exmh(library)/\\2" newfile
  75.         }
  76.         set busy(Xcursor) @$newfile
  77.     }
  78.      .* {
  79.         set busy(Xcursor) $busy(cursor)
  80.     }
  81.     }
  82. }
  83. proc BusyFixupBitmap { args } {
  84.     global busy exmh
  85.     # busy(bitmap) could be
  86.     # @foo.bitmap bar.bitmap color color
  87.     # Here we insert the exmh library
  88.     switch -regexp $busy(bitmap) {
  89.     {^@[^/]} {
  90.         regsub @(.*) $busy(bitmap) $exmh(library)/\\1 newfile
  91.         set color [lindex $newfile 1]
  92.         set newfile [lindex $newfile 0]
  93.         if [file exists $newfile] {
  94.         set busy(Xbitmap) @$newfile
  95.         } else {
  96.         Exmh_Status "Invalid file $newfile"
  97.         return
  98.         }
  99.     }
  100.      .* {
  101.         set busy(Xbitmap) [lindex $busy(bitmap) 0]
  102.         set color [lindex $busy(bitmap) 1]
  103.     }
  104.     }
  105.     if {[string length $color]} {
  106.     set busy(color) $color
  107.     } else {
  108.     set busy(color) black
  109.     }
  110. }
  111. proc busy { args } {
  112.     global busy
  113.     switch $busy(style) {
  114.     icon        {busyIcon $args}
  115.     cursorAll    {busyCursor $args}
  116.     cursor        {busyCursorHack $args}
  117.     default        {eval $args}
  118.     }
  119. }
  120. proc busyIcon { cmd } {
  121.     global errorInfo busy
  122.  
  123.     set parent [Face_BusyParent]
  124.     # Recreate the widget every time so that display works properly
  125.     if [catch {
  126.     set label \
  127.         [label $parent.busy -foreground $busy(color) -bitmap $busy(Xbitmap)]
  128.     Face_BusyPlace $label
  129.     } err] {
  130.     Exmh_Debug $err
  131.     }
  132.  
  133.     set error [catch {uplevel #0 $cmd} result]
  134.     set ei $errorInfo
  135.  
  136.     if [info exists label] {
  137.     Face_BusyDestroy $label
  138.     }
  139.  
  140.     if $error {
  141.     error $result $ei
  142.     } else {
  143.     return $result
  144.     }
  145.  
  146. }
  147. proc busyCursorInner { cmd widgets } {
  148.     global errorInfo busy
  149.     foreach w $widgets {
  150.     catch {[lindex $w 0] config -cursor $busy(Xcursor)}
  151.     }
  152.     update idletasks
  153.  
  154.     set error [catch {uplevel #0 $cmd} result]
  155.     set ei $errorInfo
  156.  
  157.     foreach w $widgets {
  158.     catch {[lindex $w 0] config -cursor [lindex $w 1]}
  159.     }
  160.     if $error {
  161.     error $result $ei
  162.     } else {
  163.     return $result
  164.     }
  165. }
  166. proc busyCursorHack {cmd} {
  167.     set widgets {}
  168.     catch {
  169.     #Fdisp_Busy
  170.     global fdisp
  171.     foreach can {canvas cache} {
  172.         if [info exists fdisp($can)] {
  173.         set w $fdisp($can)
  174.         set cursor [lindex [$w config -cursor] 4]
  175.         lappend widgets [list $w $cursor]
  176.         }
  177.     }
  178.     #Exwin_Busy
  179.     global exwin
  180.     foreach w [list $exwin(mtext) $exwin(ftext)] {
  181.         set cursor [lindex [$w config -cursor] 4]
  182.         lappend widgets [list $w $cursor]
  183.     }
  184.     #Sedit_Busy
  185.     global sedit
  186.     foreach w $sedit(allids) {
  187.         set cursor [lindex [$w config -cursor] 4]
  188.         lappend widgets [list $w $cursor]
  189.     }
  190.     #Label_Busy
  191.     global label
  192.     foreach w [list $label(main) $label(folder) $label(message) $exwin(status)] {
  193.         set cursor [lindex [$w config -cursor] 4]
  194.         lappend widgets [list $w $cursor]
  195.     }
  196.     }
  197.     return [busyCursorInner $cmd $widgets]
  198. }
  199. proc busyCursor {cmd} {
  200.     set widgets {.app .root}
  201.     set list [winfo children .]
  202.     while {$list != ""} {
  203.     set next {}
  204.     foreach w $list {
  205.         set cursor [lindex [$w config -cursor] 4]
  206.         lappend widgets [list $w $cursor]
  207.         set next [concat $next [winfo children $w]]
  208.     }
  209.     set list $next
  210.     }
  211.     return [busyCursorInner $cmd $widgets]
  212. }
  213.  
  214.